home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / GFXFX2.ZIP / WORMHOL2.PAS < prev    next >
Pascal/Delphi Source File  |  1995-02-14  |  2KB  |  103 lines
  1.  
  2. {$define fast} { 'uncomment' for fast computers, 'comment' for slow comps. }
  3.  
  4. program wormhole; { WORMHOL2.PAS }
  5. { Another way to do the Wormhole.
  6.   Realy only for fast computers.
  7.   This one is REAL 3D (and has the
  8.   'moving' effect in it)...
  9.   By Bas van Gaalen }
  10. uses u_vga,u_pal,u_3d,u_kb;
  11. const
  12.   nofcircles=70;
  13.   zstep=5;
  14.   radius=50;
  15.   vidbuf=ptr($a000,0);
  16. {$ifdef fast}
  17.   astep=8;
  18. {$else}
  19.   astep=15;
  20. {$endif}
  21.  
  22. procedure hole;
  23. var
  24.   circle:array[0..255 div astep] of record x,y:word; end;
  25.   zpos:array[1..nofcircles] of integer;
  26.   virscr:pointer;
  27.   si,i,j,angle:word;
  28.   xo,yo,xp,yp,x,y,z:integer;
  29.  
  30. procedure sort(l,r:integer);
  31. var i,j,x,y:integer;
  32. begin
  33.   i:=l; j:=r; x:=zpos[(l+r) div 2];
  34.   repeat
  35.     while zpos[i]<x do inc(i);
  36.     while x<zpos[j] do dec(j);
  37.     if i<=j then begin
  38.       y:=zpos[i]; zpos[i]:=zpos[j]; zpos[j]:=y;
  39.       inc(i); dec(j);
  40.     end;
  41.   until i>j;
  42.   if l<j then sort(l,j);
  43.   if i<r then sort(i,r);
  44. end;
  45.  
  46. begin
  47.   for i:=0 to 255 div astep do begin
  48.     circle[i].x:=radius*ctab[i*astep] div (divd-20);
  49.     circle[i].y:=radius*stab[i*astep] div divd;
  50.   end;
  51.   z:=-200;
  52.   for i:=1 to nofcircles do begin zpos[i]:=z; inc(z,zstep); end;
  53.   getmem(virscr,64000);
  54.   si:=0;
  55.   repeat
  56.     cls(virscr,64000);
  57.     sort(1,nofcircles);
  58.     vretrace;
  59.     for j:=1 to nofcircles do begin
  60.       angle:=0; i:=0;
  61.       xo:=ctab[(si+2*j) mod 255] div 3+stab[(2*si+3*j) mod 255] div 4;
  62.       yo:=stab[(si+2*j) mod 255] div 3+stab[(3*si+2*j) mod 255] div 5;
  63.       while angle<255 do begin
  64.         conv3dto2d(xp,yp,circle[i].x,circle[i].y,zpos[j]);
  65.         inc(xp,xo+160); inc(yp,yo+100);
  66.         asm
  67.           mov dx,xp
  68.           cmp dx,0
  69.           jl @out
  70.           cmp dx,319
  71.           jg @out
  72.           mov ax,yp
  73.           cmp ax,0
  74.           jl @out
  75.           cmp ax,199
  76.           jg @out
  77.           les di,virscr
  78.           shl ax,6
  79.           add di,ax
  80.           shl ax,2
  81.           add di,ax
  82.           add di,dx
  83.           mov ax,j
  84.           mov es:[di],al
  85.          @out:
  86.         end;
  87.         inc(angle,astep); inc(i);
  88.       end;
  89.       inc(zpos[j]); if zpos[j]>(-200+nofcircles*zstep) then zpos[j]:=-200;
  90.     end;
  91.     flip(virscr,vidbuf,64000); inc(si,2);
  92.   until keypressed;
  93.   freemem(virscr,64000);
  94. end;
  95.  
  96. var i:byte;
  97. begin
  98.   setvideo($13);
  99.   for i:=1 to nofcircles do setrgb(i,15+i shr 2,15+i shr 2,20+i shr 2);
  100.   hole;
  101.   setvideo(u_lm);
  102. end.
  103.